COMMENT ⊗   VALID 00017 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	.SBTTL SMALL BLOCK ALLOCATOR
C00006 00003	 Definitions of fields
C00009 00004	 DEFSPC
C00011 00005	 DATA AREA
C00012 00006	 MAPPTR, MARKR0, LNKMTH
C00016 00007	 MARKPH, MKPHRT, MKROUT
C00018 00008	ROUTINE CPFYSP,<SPC>
C00022 00009	ROUTINE CPFY
C00023 00010	ROUTINE SWEEP
C00026 00011	ROUTINE GC
C00027 00012	 GETSBK, GETBLK
C00030 00013	 FREBLK, FRESBK
C00032 00014	 NEWSPC, SETSPC
C00034 00015	ROUTINE ADDBUF,<SPACE>
C00036 00016	 Standard spaces, SBINIT
C00038 00017	.IFNZ	SMBDBG		Test routine
C00040 ENDMK
C⊗;
.SBTTL SMALL BLOCK ALLOCATOR
;Coded by RHT 9-Sept-1974

SMBDBG == 1	;WE ARE DEBUGGING

COMMENT ⊗

Overview: The basic idea is to break up large blocks of storage into
smaller, fixed size blocks, and then administer them.  The routines
given here provide a facility whereby a user can have a number of
different "spaces" of fixed size blocks.  Each space is described by
an approximately 10 word space descriptor.  All these space
descriptors are linked together on a big chain (SIDLST), and each
space is assumed to have asociated with it a unique 8-bit number
(thus allowing up to 256 spaces).  Each space descriptor owns a
linked list of buffers; each buffer contains a number of blocks.
Each space may be either collectable or uncollectable.  Any block may
be released explicitly, although if the space is collectable, this
may be unwise.  Also, collectable spaces are compactified by the
garbage collector.  As an efficiency measure, the first few indices
[of what? - RF] (now, 1-10) are also kept in a table (SIDTBL). 
 
 Blocks are allocated by the routines GETBLK & GETSBK:
 
 	MOV	#IDCODE,R0	 ;IDCODE is the 8-bit code for a space
 	JSR	PC,GETBLK	 ;
 
 	MOV	#SPCDSC,R0	 ;SPCDSC is the address of the space
 	JSR	PC,GETSBK	 ;descriptor
 
In either case, a pointer to a new block is returned in R0.  If need
be, the free space routine will call the garbage collector to get
more space or (if the space is not collectable or garbage collection
is disabled) it will call the large block routines to get another
buffer.  If garbage collection fails to produce a goodly surplus of
blocks for some space, then additional buffers of new blocks will be
obtained. 
 
Each small block has the following format:

 		TAB,,ID		 tag is used in garbage collecting
 	R0 →→	WORD 0		 this is the word pointed to by getblk
 		:
 		WORD n
 
Blocks are zeroed before being returned.  Although this is sometimes
a bit extra overhead, it does prevent bugs and avoids the necessity
for explicit clears all over the place. 
 
Blocks are freed by the routines FREBLK & FRESBK:
 
 	MOV	BLOCK,R0	 ;R0 ← block to free
 	JSR	PC,FREBLK
 
 	MOV	BLOCK,R0	 ;R0 ← block to free
 	MOV	#SPCDSC,R1	 ;R1 ← space descriptor
 	JSR	PC,FRESBK
 
The macro 
 	 DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
may be used to declare compiled-in space descriptors.  Please see the
comment on routine MAPPTR for additional instuctions for declaring
spaces. 
⊗
; Definitions of fields

;SPACE DESCRIPTOR

	II == 0
	XX	IDFLAG	;Actually a byte; gets put in the ID part of tag word
	XX	MAPRTN	;Routine to be called when marking
	XX	SIZE	;How many words for a value cell in this type block.
	XX	NPERB	;Number of blocks per buffer
	XX	GCFG	;Set if this is not a collectable area
	XX	NMIN	;Min number of free blocks to be returned by GC
	XX	NPCT	;Min % of free blocks to be returned by GC
	XX	NXTSID	;Next space descriptor on ID chain
	XX	FFREE	;Free list [??? - RF]
	XX	FSTBUF	;Oldest buffer
	XX	LSTBUF	;Newest buffer
	XX	NALLOC	;Number of buffers allocated
	XX	NFREE	;Number of buffers free
	SPCHDR == II	;Number of bytes in a space descriptor

; BUFFER HEADER
	II == 0
	XX	NXTBUF	;Next buffer in this space
	XX	PRVBUF	;Previous buffer in this space
	XX	LSTBLK	;Address of last block in this buffer
	XX	FSTBLK	;Address of first block in this buffer, word 0.
	BUFHDR == II	;Number of bytes in a buffer header

; SMALL BLOCK
	II == 0
	TAG == -1	; ≠ 0 means in use (used by GC)
	TAGID == -2	;Holds an "ID" for this record
	XX	WORD0	;First data word

; GC METHODS
	II == 0
	XX	METH	;Address of routine to call
	XX	NXTMTH	;Next CG method on chain

; Marking method macro
       .MACRO MMETH ROUT
	ROUT
	0
       .ENDM
; DEFSPC

; Assemble-time spaces
       .IF2
	SIDHED == SIDCHN ;Sets SIDHED to the final value of SIDCHN
       .ENDC

SIDCNT == 0		;Number of assembled-in space descriptors
SIDCHN == 0		;Linkage for assembled-in space descriptors

COMMENT ⊗ Declare assembled-in space descriptors: Makes a space
descriptor.  ID is given the number of the space.  MMRT is the map
routine, SZ the size, NPB the number of blocks per buffer, GCF is set
if the area is not to be collected, NMN is the minimum number of free
blocks that GC should return, NPC is the minimum percent of free
blocks that GC should return.  ⊗

.MACRO DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC
    .IFNDF ID
	SIDCNT==SIDCNT+1
	ID==SIDCNT
    .ENDC
    II==.
    .BLKW SPCHDR/2
	TT	IDFLAG,ID
	TT	MAPRTN,MMRT
	TT	SIZE,SZ
	TT	NPERB,NPB
	TT	GCFG,GCF
	TT	NMIN,NMN
	TT	NPCT,NPC
	TT	NXTSID,SIDCHN
	TT	FFREE,0
	TT	FSTBUF,0
	TT	LSTBUF,0
	TT	NALLOC,0
	TT	NFREE,0
    SIDCHN == II
    .=II+SPCHDR
      .IF2
	.IFGE MAXIDF-ID
	  PUTLOC <ID*2 + SIDTBL>,SIDCHN
	.ENDC
      .ENDC
.ENDM

; DATA AREA

MMETHS:	0		;Header of list of marking methods
GCOK:	0		;Set if GC is OK now
CPFYOK:	0		;Set if compactification is OK
SIDLST:			;List of space descriptor blocks
	.IF1		;Let pass 2 of assemble fix this up
		0
	.ENDC
	.IF2
		SIDHED
	.ENDC

MAXIDF == 30		;Max index into SIDTBL
SIDTBL:	0		;Table of space descriptors for efficiency
	.BLKB MAXIDF
; MAPPTR, MARKR0, LNKMTH

ROUTINE MAPPTR,<ROUT>	
 
COMMENT ⊗ MAPPTR takes a single parameter (in R0) which is a pointer
to a small block.  It returns (in R0) a pointer value which is to be
stored back in the pointer cell.  

MAPPTR runs down a list of "marking methods" (MMETHS).  Each method
is assumed to be responsible for some batch of pointers.  For each
pointer it finds, a method should call the routine MARKR0 (via JSR
PC).  Thus, each marking method should have the form

 	METH:	R←#<first pointer>
 		WHILE R≠NULL DO
 			BEGIN
 			R0←(R);
 			JSR PC,MARKR0;
 			(R)←R0;
 			R←#<next pointer>;
 			END;
 		RETURN;
 
MARKR0 determines the type of the record (finds its space descriptor).
It then does a 
 		JSR	PC,@MAPRTN(<space>)
for spaces where there are no pointer subfields; this may be just
MKRTJM (ie, a JMP @2(RF) ).  If there are pointer subfields, then the
MAPRTN needs to be more complicated:
 
 		IF TAG(R0) THEN RTS PC;
 		JSR	PC,@2(RF);
 		PUSH R;
 		R←R0;
 		∀ <field> | <field> is a pointer subfield of R DO
 			BEGIN
 			R0←<field>
 			JSR	PC,MARKR0;
 			<field>←R0;
 			end;
 		R0←R;
 		POP R;
 		RTS PC;
 
Note: it may be a good idea to change the conventions here a bit to
(1) pass a pointer at a record pointer & (2) let markr0 assume
responsibility for storing the updated pointer.  The advantage of
such a course is that it allows iterative marking of long lists, thus
avoiding possible pdl overflows. 
⊗

;MAPPTR:	;(IN CASE YOU HAD FORGOTTEN)
	MOV	R2,-(SP)	;
	MOV	MMETHS,R2	;LIST OF MARKING METHS
	BEQ	MAPRTS		;DONE??
MAPLP:	CALL	@METH(R2),<ROUT(RF)>
	MOV	NXTMTH(R2),R2	;NEXT METHOD
	BNE	MAPLP		;ITERATE
MAPRTS:	MOV	(SP)+,R2	;
	RTS	RF		;RETURN

MKRTJM:	JMP	@ROUT(RF)	;THIS IS THE APPROPRIATE 
				;MARKING INTRINSIC FOR CASES WHERE
				;THERE ARE NO POINTER SUBFIELDS

MARKR0:	TST	R0		;A NULL IS A NULL
	BEQ	MR0.X		;	IS A NULL
	JSR	PC,PTRSID	;GETS SPACE DESCRIPTOR INTO R1
	JSR	PC,@MAPRTN(R1)	;CALL APPROPRIATE MARKING INTRINSIC
MR0.X:	RTS	PC

; Add a method to the "MMETHS" list:
LNKMTH:	MOV	MMETHS,NXTMTH(R0)
	MOV	R0,MMETHS
	RTS	PC
; MARKPH, MKPHRT, MKROUT

ROUTINE MARKPH		
	MOV	R2,-(SP)	;
	MOV	R3,-(SP)	;
	MOV	SIDLST,R2	;ALL SIZES
	BEQ	MKPHRT		;DONE ALREADY??
MKPH.1:	TST	GCFG(R2)	;A GC SPACE??
	BEQ	MKPH.AD		;NO, GO ON TO NEXT
	MOV	SIZE(R2),R3	;
	INC	R3		;ONE FOR TAG WORD
	ASL	R3		;WORDS TO BYTES
	MOV	FSTBUF(R2),R1	;CLEAR THIS BUFFER
MKP.02:	MOV	FSTBLK(R1),R0	;FIRST BLOCK
MKPH.2:	CMP	R0,LSTBLK(R1)	;DONE THIS BUFFER?
	BGT	MKPH.3		;IF SO, GO ON TO NEXT
	CLRB	TAG(R0)		;CLEAR TAG
	ADD	R3,R0		;BUMP POINTER TO NEXT
	BR	MKPH.2		;ITERATE
MKPH.3:	MOV	NXTBUF(R1),R1	;ON TO NEXT BUFFER
	BNE	MKP.02		;IF WE HAVE ONE
MKPH.AD:MOV	NXTSID(R2),R2	;GO ON TO NEXT SPACE
	BNE	MKPH.1		;

	CALL	MAPPTR,<#MKROUT> ;DO THE ACTUAL MARKING
	
MKPHRT:	MOV	(SP)+,R3	;RESTORE
	MOV	(SP)+,R2
	RTS	RF

MKROUT:	MOVB	#377,TAG(R0)	;
	RTS	PC		;

ROUTINE CPFYSP,<SPC>

; Performs all data moving required to compactify one size space

	MOV	R2,-(SP)	;SAVE SOME ACS
	MOV	R3,-(SP)	;
	MOV	R4,-(SP)	;
	MOV	SPC(RF),R2	;SPACE DSCR
	MOV	FSTBUF(R2),R3	;OLDEST
	MOV	LSTBUF(R2),R4	;NEWEST
	JSR	PC,NXF.0	;NEXT FREE INTO 1
				;MAY MODIFY R3
	BEQ	CPFY.2		;NO FREE
	JSR	PC,NXR.0	;GET A RECORD TO MOVE
				;INTO R1 (MAY MUNCH R0)
	BEQ	CPFY.2		;
CPFY.1:	MOV	R1,-(SP)	;SAVE THESE
	MOV	R0,-(SP)	;
	MOVB	#377,TAG(R0)	;
	CLRB	TAG(R1)		;
	MOV	SIZE(R2),R2	;
CPYR:	MOV	(R1)+,(R0)+	;COPY RECORD
	DEC	R2		;COUNT DOWN
	BGT	CPYR		;DONE??
	MOV	SPC(RF),R2	;YES
	MOV	(SP)+,R0	;GET ACS BACK
	MOV	(SP)+,R1	;
	MOV	R0,WORD0(R1)	;POINT AT THIS ONE
	JSR	PC,NXF.NX	;NEXT FREE
	BEQ	CPFY.2
	JSR	PC,NXR.NX	;NEXT RECORD
	BNE	CPFY.1		;PROCESS THAT ONE
CPFY.2:
	MOV	(SP)+,R4	;
	MOV	(SP)+,R3	;
	MOV	(SP)+,R2
	RTS	RF

NXF.0:	MOV	FSTBLK(R3),R0	;FIND A FREE BLOCK
NXF.1:	TSTB	TAG(R0)		;FREE
	BEQ	NXF.4		;YES
NXF.NX:	ADD	SIZE(R2),R0	;LOOK AT NEXT
	ADD	SIZE(R2),R0	;ADD TWICE SINCE WANT TRUE ADDRESS
	TST	(R0)+		;ADD IN TAG WORD OFFSET
	CMP	R0,LSTBLK(R3)	;MORE TO TRY??
	BLE	NXF.1		;TRY AGAIN
	MOV	NXTBUF(R3),R3	;NEXT NEWEST BUFFER
	BEQ	NXF.3		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE R SUPPLIER
	BNE	NXF.0
NXF.3:	CLR	R0
NXF.4:	MOV	R0,R0		;GET FLAGS CORRECT
	RTS	PC


NXR.0:	MOV	FSTBLK(R4),R0	;FIND A FULL BLOCK
NXR.1:	TSTB	TAG(R0)		;FULL
	BNE	NXF.4		;YES
NXR.NX:	ADD	SIZE(R2),R0	;LOOK AT NEXT
	ADD	SIZE(R2),R0	;ADD TWICE SINCE WANT TRUE ADDRESS
	TST	(R0)+		;ADD IN TAG WORD OFFSET
	CMP	R0,LSTBLK(R4)	;MORE TO TRY??
	BLE	NXR.1		;TRY AGAIN
	MOV	PRVBUF(R4),R4	;NEXT NEWEST BUFFER
	BEQ	NXR.3		;LOOK THERE
	CMP	R3,R4		;IF NOT TO THE R SUPPLIER
	BNE	NXF.0
NXR.3:	CLR	R0
NXR.4:	MOV	R0,R0		;GET FLAGS CORRECT
	RTS	PC
ROUTINE CPFY
	MOV	R2,-(SP)	
	MOV	SIDLST,R2	;LIST OF ALL SIZES
	BEQ	CPFYXX		;NULL LIST??
CPFYLP:	TST	GCFG(R2)	;COLLECTABLE??
	BEQ	CPFYNX		;BR IF NOT
	CALL	CPFYSP,<R2>	;COMPACTIFY THIS SPACE
CPFYNX:	MOV	NXTSID(R2),R2
	BNE	CPFYLP
CPFYXX:	CALL	MAPPTR,<#MUNLNK> ;MUNCH ALL LINKS
	; **** HERE IS THE SPOT WHERE YOU SHOULD WORRY ABOUT
	;      GETTING RID OF EXCESS BUFFER BLOCKS ****
CPFYRT:	MOV	(SP)+,R2	;RETURN
	RTS	RF

MUNLNK:	MOV	(R0),R1		;CALLED WITH R0 →→ A PTR
	TST	TAG(R1)		;DID WE MOVE IT ??
	BNE	MUNRTS		;
	MOV	WORD0(R1),(R0)	;YES, PUT NEW POINTER IN PLACE
MUNRTS:	RTS	PC		;

ROUTINE SWEEP
	MOV	R2,-(SP)	;
	MOV	SIDLST,R2	;LIST OF SIZES
	BEQ	SWP.X
SWP.LP:	JSR	PC,SWP.		;GO SWEEP ONE AREA
	MOV	NXTSID(R2),R2	;ITERATE
	BNE	SWP.LP		;
SWP.X:	MOV	(SP)+,R2	;
	RTS	RF		;

ROUTINE SWEEP1,<SPCC>	
	MOV	R2,-(SP)	;SAVE REGISTERS
	MOV	SPCC(RF),R2	;GET A SPACE
	JSR	PC,SWP.		;SWEEP ONE AREA
SWP.XX:	MOV	(SP)+,R2	
	RTS	RF

SWP.:	TST	GCFG(R2)	;IS THIS SPACE FOR SWEEPING??
	BNE	SWP.00		;
	RTS	PC		;NO
SWP.00:	MOV	R3,-(SP)	;YES
	MOV	R4,-(SP)	;
	CLR	FFREE(R2)	;WILL BUILD A REAL FREE LIST
	CLR	NFREE(R2)	;SINCE WE WILL FIX COUNTS
	CLR	NALLOC(R2)	;
	MOV	FSTBUF(R2),R3	;OLDEST BUFFER
	BEQ	SWP.3		;IF ANY
	MOV	SIZE(R2),R4	;COMPUTE SIZE
	INC	R4		;IN BYTES OF WHOLE THING
	ASL	R4		;
SWP.01:	MOV	FSTBLK(R3),R0	;GET A BLK
SWP.1:	TSTB	TAG(R0)		;ALLOCATED?
	BEQ	SWP.1N		;NO
	INC	NALLOC(R2)	;YES
	BR	SWP.2
SWP.1N:	INC	NFREE(R2)	;LINK UP A FREE
	MOV	FFREE(R2),WORD0(R0)
	MOV	R0,FFREE(R2)
SWP.2:	ADD	R4,R0		;BUMP POINTER TO NEXT IN BUFFER
	CMP	R0,LSTBLK(R3)	;DONE BUFFER??
	BLE	SWP.1		;NO
	MOV	NXTBUF(R3),R3	;YES GO ON TO NEXT
	BNE	SWP.01		;IF THERE IS ONE
SWP.3:	CMP	NFREE(R2),NMIN(R2)	;NEED MORE??
	BGT	SWP.5		;AT LEAST HAVE MIN NUMBER
SWP.4:	CALL	ADDBUF,<R2>	;NO, ADD A BUFFER FULL
	BR	SWP.3		;AND TRY AGAIN
SWP.5:	MOV	NFREE(R2),R0	;SEE IF HIGH ENOUGH PERCENTAGE
	ADD	NALLOC(R2),R0	;OF FREES
	MUL	NPCT(R2),R0	; 
	DIV	#144,R0		; NPCT*(NFREE+NALLOC)/=100
	CMP	NFREE(R2),R0	;
	BGT	SWP.6		;IF DONT HAVE ENOUGH
	CALL	ADDBUF,<R2>	;GET A BUFFER LOAD
	BR	SWP.5		;AND TRY AGAIN
SWP.6:	MOV	(SP)+,R4	;RESTORE
	MOV	(SP)+,R3
	RTS	PC

ROUTINE GC
	CALL	MARKPH		;MARK EVERYONE
	TST	CPFYOK		;IF DONT WANT COMPACTIFICATION
	BEQ	SWPPIT		;THEN DONT DO IT
	CALL	CPFY		;COMPACTIFY
SWPPIT:	CALL	SWEEP		;SWEEP UP LOOSE GARBAGE
	RTS	RF
; GETSBK, GETBLK

GETSBK:	
;
;	MOV	[SPACE DESCRIPTOR],R0
;	JSR	PC,GETSBK
;	<RETURNS WITH A BLOCK IN R0>
;
	MOV	R0,R1			
GETBL1:	TST	R1			;ERROR TRAP
	BEQ	GETBER
	MOV	FFREE(R1),R0		;R0 ← FIRST FREE
	BNE	GETBLX			;DID WE GET ONE
	MOV	R1,-(SP)		;NO,
	TST	GCFG(R1)		;IS GC OK FOR THIS AREA?
	BEQ	GETADB			;NO, MUST ADD
	TST	GCOK			;IS GARBAGE COLLECTION OK AT ALL
	BNE	GETGC			;
GETADB:	CALL	ADDBUF,<R1>		;NO, JUST GET A BUFFER
	BR 	GETBXX			;
GETGC:	CALL	GC			;YES, GC
GETBXX:	MOV	(SP)+,R1		;
	BR	GETBL1
GETBLX:	MOV	WORD0(R0),FFREE(R1)	;NEW FREE LIST
	INC	NALLOC(R1)		;ADJUST COUNTS
	DEC	NFREE(R1)
	MOVB	IDFLAG(R1),TAGID(R0)	;REMEMBER WHAT IT IS
	MOV	R0,-(SP)		;SAVE POINTER TO BLOCK
	MOV	SIZE(R1),R1		;WORD COUNT
GETB.C:	CLR	(R0)+			;CLEAR A WORD
	DEC	R1			;COUNT DOWN
	BGT	GETB.C			;UNTIL DONE
	MOV	(SP)+,R0		;RETURN VALUE BACK
	RTS	PC

;
;	MOV	#ID,R0
;	JSR	PC,GETBLK
;
GETBLK:	JSR	PC,GETSID		;SET UP SPC DSCR IN R1
	BR	GETBL1

GETBER:	HALERR	GERMSG
	CLR	R0
	RTS	PC

GERMSG:	ASCIE	/ATTEMPT TO ALLOCATE RECORD WITHOUT GIVING DESCRIPTOR/

GETSID:	MOV	R0,R1
	CMP	R0,#MAXIDF		;IN THE TABLE?
	BGT	GETS.1			;NO
	ASL	R1
	MOV	SIDTBL(R1),R1		;YES
GETS.X:	RTS	PC			;
GETS.1:	MOV	SIDLST,R1		;SEARCH CHAIN
	BEQ	GETS.X
GETS.2:	CMP	R0,IDFLAG(R1)		;THIS ONE??
	BNE	GETS.X			;YES
	MOV	NXTSID(R1),R1		;NO, TRY NEXT
	BNE	GETS.2
	RTS	PC

PTRSID:	MOV	R0,-(SP)		;SINCE GETSID WILL MUNCH
	MOVB	TAGID(R0),R0		;THE ID FLAG
	JSR	PC,GETSID		;GET SID INTO R1
	MOV	(SP)+,R0		;GET PTR BACK
	RTS	PC
; FREBLK, FRESBK

;	MOV	BLK,R0
;	JSR	PC,FREBLK

FREBLK: MOV	SIDLST,R1	;FIND THE SPACE
	BEQ	FREBER		;THIS CAME FROM
FREB.1:	CMPB	TAGID(R0),IDFLAG(R1) ;WAS IT THIS AREA
	BNE	FREB.2		;NO
FREB.:	MOV	FFREE(R1),WORD0(R0);FOUND THE AREA, PUT ON FREE CHAIN
	MOV	R0,FFREE(R1)
	INC	NFREE(R1)	;ADJUST COUNTS
	DEC	NALLOC(R1)
	CLRB	TAG(R0)		;JUST FOR RANDOMNESS
	RTS	PC		;DONE
FREB.2:	MOV	NXTSID(R1),R1	;LOOK AT NEXT
	BNE	FREB.1		;ITERATE
FREBER:	HALERR	FRERMS
FRERMS:	ASCIE	/ATTEMPT TO DELETE A BLOCK FROM AN AREA I CANNOT FIND/
	RTS	PC

FRESBK:	CMPB	TAGID(R0),IDFLAG(R1)	;BE SURE THIS IS OK
	BEQ	FREB.		;WE WIN
	HALERR	FRBER2
	BR	FREB.		;DO IT ANYHOW IF CONTINUES IT

FRBER2:	ASCIE	/ID DISAGREEMENT FOR FRESBK/
; NEWSPC, SETSPC

COMMENT ⊗ Create a space descriptor.  SZ is the size, IDF the IDFLAG,
NPB the number of blocks per buffer, GCF is set if the area is not to
be collected, NMN is the minimum number of free blocks that GC should
return, NPC is the minimum percent of free blocks that GC should
return.  R0 returns the address of the new space descriptor.  ⊗
ROUTINE NEWSPC,<SZ,IDF,NPB,GCF,NMN,NPC>

	MOV	#SPCHDR/2,R0	;GET A BLOCK OF CORE
	JSR 	PC,GTFREE
	MOV	SZ(RF),SIZE(R0) ;REMEMBER HOW BIG
	MOV	NPB(RF),NPERB(R0) ;
	MOV	IDF(RF),IDFLAG(R0) ;
	MOV	NMN(RF),NMIN(R0);
	MOV	NPC(RF),NPCT(R0);
NEWS.1:	MOV	SIDLST,NXTSID(R0)  ;LINK ONTO ID CHAIN
	MOV	R0,SIDLST
	MOV	IDFLAG(R0),R1	;WILL IT FIT IN ID CHAIN
	CMP	R1,#MAXIDF	;WILL IT FIT INTO TABLE
	BGT	NEWS.2		;
	ASL	R1		;YES
	MOV	R0,SIDTBL(R1)	;PUT INTO TABLE
NEWS.2:	CLR	FSTBUF(R0)	;ZERO OUT OTHER THINGS
	CLR	LSTBUF(R0)	;
	CLR	NALLOC(R0)
	CLR	NFREE(R0)
	RTS	RF		;RETURN

COMMENT ⊗ Initialize a space descriptor.  SPCADR is its address.  It
will be linked into the ID chanin, put in the SIDTBL if it fits, and
it will be cleared of all buffers.  ⊗
ROUTINE SETSPC,<SPCADR>
	MOV	SPCADR(RF),R0	;
	BR	NEWS.1		;GO INITIALIZE ALL NON-CONSTANT THINGS
ROUTINE ADDBUF,<SPACE>
;ADDS ANOTHER BUFFER TO THE NAMED SPACE
	MOV	R2,-(SP)		;SAVE A REGISTER
	MOV	R3,-(SP)
	MOV	SPACE(RF),R2
	MOV	SIZE(R2),R1		;CALCULATE WORD REQUIREMENTS
	INC	R1			;ONE WORD OVERHEAD FOR TAG & ID BYTES
	MOV	R1,-(SP)		;WILL NEED THIS LATER
	MUL	NPERB(R2),R1		;SIZE*NUMBER OF BLOCKS
	ADD	#BUFHDR/2,R1		;
	MOV	R1,R0			;
	JSR	PC,GTFREE		;GET A BLOCK
	MOV	LSTBUF(R2),R1		;LINK ONTO CHAIN
	MOV	R1,PRVBUF(R0)		;LINK BACK
	BEQ	ADB.01			;
	MOV	R0,NXTBUF(R1)		;AND PERHAPS FORWARD
	BR	ADB.1			;
ADB.01:	MOV	R0,FSTBUF(R2)		;IF WAS NO LSTBUF, THEN THIS IS FSTBUF
ADB.1:	CLR	NXTBUF(R0)		;CLEAN UP
	MOV	R0,LSTBUF(R2)		;NEW NEWEST BLOCK
	MOV	R0,R3			;
	ADD	#2+BUFHDR,R3		;POINTER AT FIRST BLOCK
	MOV	R3,FSTBLK(R0)		;REMEMBER IT
	MOV	NPERB(R2),R1		;
	ASL	(SP)			;NUMBER OF BYTES TO STEP BY
	SUB	(SP),R3			;TO UNDO FIRST ADD

ADB.2:	ADD	(SP),R3
	INC	NFREE(R2)		;ONE MORE FREE
	CLRB	TAG(R3)			;CLEAR TAG
	MOVB	IDFLAG(R2),TAGID(R3)	;SET TYPE ID
	MOV	FFREE(R2),WORD0(R3)	;CONS ONTO FREE LIST
	MOV	R3,FFREE(R2)		;
	DEC	R1			;ITERATE
	BGT	ADB.2			;IF ANY LEFT

	MOV	R3,LSTBLK(R0)		;R3 NOW POINTS AT LAST BLOCK
	TST	(SP)+			;POP
	MOV	(SP)+,R3		;RESTORE ACS
	MOV	(SP)+,R2
	RTS	RF

; Standard spaces, SBINIT

;Recall that MACRO DEFSPC ID,MMRT,SZ,NPB,GCF,NMN,NPC

SCASPC:	DEFSPC	VCTID,MKRTJM,2,10,0,4,15
VCTSPC:	DEFSPC	VCTID,MKRTJM,10,10,0,4,15
TRNSPC:	DEFSPC	VCTID,MKRTJM,40,4,0,2,15
CELSPC:	DEFSPC	VCTID,MKRTJM,2,10,1,4,15

ROUTINE SBINIT
; Initializes the small block allocator with the standard spaces.
	CLR	SIDLST
	CLR	GCOK
	CLR	CPFYOK
	CLR	MMETHS
	CALL	SETSPC,<#SCASPC>
	CALL	SETSPC,<#VCTSPC>
	CALL	SETSPC,<#TRNSPC>
	CALL	SETSPC,<#CELSPC>
	RTS	RF

.IFNZ	SMBDBG		;Test routine


FSTEST:	CALL	SBINIT
	MOV	#20,R2
	MOV	#VCTARA,R3
FST.1:	MOV	#VCTID,R0
	JSR	PC,GETBLK
FST.2:	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.1
FST.3:	MOV	#13,R2
FST.4:	MOV	-(R3),R0
	JSR	PC,FREBLK
	DEC	R2
	BGT	FST.4
FST.5:	MOV	#17,R2
FST.6:	MOV	#VCTID,R0
	JSR	PC,GETBLK
	MOV	R0,(R3)+
	DEC	R2
	BGT	FST.6
FST.10:	MOV	#TSTMTH,R0
	JSR	PC,LNKMTH
	MOV	R3,VCTUB
	SUB	#2,VCTUB
	MOV	#VCTARA,VCTLB
	MOV	#-1,GCOK
	CALL	GC
FST.11:	MOV	#10,R2
FST.12:	MOV	#VCTSPC,R0
	JSR	PC,GETSBK
	DEC	R2
	BGT	FST.12

	HALERR	DNMSG

DNMSG:	ASCIE	</
WELL HOW DID WE DO?/>

VCTARA:	.BLKW	200
VCTUB:	0
VCTLB:	0

TSTMTH:	MMETH	TSTRTN

ROUTINE TSTRTN,<RTN>
	MOV	R2,-(SP)
	MOV	VCTLB,R2
TST.R1:	CMP	R2,VCTUB
	BGT	TSTRTS
	MOV	(R2),R0
	JSR	PC,MARKR0
	MOV	R0,(R2)+
	BR	TST.R1
TSTRTS:	MOV	(SP)+,R2
	RTS	RF

.ENDC